home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / b / b.lha / B / src / bint / b3sou.c < prev    next >
Encoding:
C/C++ Source or Header  |  1988-11-24  |  21.2 KB  |  907 lines
  1. /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
  2.  
  3. /*
  4.   $Header: b3sou.c,v 1.4 85/08/22 16:59:08 timo Exp $
  5. */
  6.  
  7. /* Sources: maintaining units and values on external files */
  8.  
  9. #include "b.h"
  10. #include "b0con.h"
  11. #include "b0fea.h"
  12. #include "b0fil.h"
  13. #include "b1mem.h"
  14. #include "b1obj.h"
  15. #include "b2syn.h"
  16. #include "b2par.h"
  17. #include "b2nod.h"
  18. #include "b3env.h"
  19. #include "b3scr.h"
  20. #include "b3err.h"
  21. #include "b3sem.h"
  22. #include "b3fil.h"
  23. #include "b3sou.h"
  24. #include "b3int.h"
  25.  
  26. /************************** UNITS ************************************/
  27.  
  28. Hidden value b_perm; /* The table that maps tags to their file names */
  29. Hidden value b_units; /* The table that maps tags to their internal repr. */
  30.  
  31. Hidden bool
  32. u_exists(pname, aa)
  33.     value pname, **aa;
  34. {
  35.     return in_env(b_units, pname, aa);
  36. }
  37.  
  38. Visible Procedure
  39. def_unit(pname, u)
  40.     value pname, u;
  41. {
  42.     e_replace(u, &b_units, pname);
  43. }
  44.  
  45. Hidden Procedure
  46. free_unit(pname)
  47.     value pname;
  48. {
  49.     e_delete(&b_units, pname);
  50. }
  51.  
  52. Hidden Procedure
  53. del_units()
  54. {
  55.     int len= length(b_units), k; how *u;
  56.     for (k= len-1; k >= 0; --k) {
  57.         /* Reverse loop so deletions don't affect the numbering! */
  58.         u= How_to(*assoc(b_units, k));
  59.         if (!u->unparsed) free_unit(*key(b_units, k));
  60.         /*Therefore standard B functions must be entered as unparsed*/
  61.     }
  62. }
  63.  
  64. Visible Procedure
  65. rem_unit(u)
  66.     parsetree u;
  67. {
  68.     value pname= get_pname(u);
  69.     free_unit(pname);
  70.     release(pname);
  71. }
  72.  
  73. /********************************************************************** */
  74.  
  75. Visible Procedure
  76. p_name_type(pname, name, type)
  77.     value pname, *name; literal *type;
  78. {
  79.     *name= behead(pname, MkSmallInt(2));
  80.     switch (strval(pname)[0]) {
  81.     case '0': *type= Zer; break;
  82.     case '1': *type= Mon; break;
  83.     case '2': *type= Dya; break;
  84.     case '3': *type= How; break;
  85.     case '4': *type= Tar; break;
  86.     default: syserr(MESS(4000, "p_name_type"));
  87.         /* NOTREACHED */
  88.     }
  89. }
  90.  
  91. Visible value
  92. permkey(name, type)
  93.     value name; literal type;
  94. {
  95.     value v, w; string t;
  96.     switch (type) {
  97.     case Zer: t= "0"; break;
  98.     case Mon: t= "1"; break;
  99.     case Dya: t= "2"; break;
  100.     case How: t= "3"; break;
  101.     case Tar: t= "4"; break;
  102.     default: syserr(MESS(4001, "wrong permkey"));
  103.     }
  104.     w= mk_text(t);
  105.     v= concat(w, name); release(w);
  106.     return v;
  107. }
  108.  
  109. Visible bool
  110. p_exists(pname, aa)
  111.     value pname, **aa;
  112. {
  113.     return in_env(b_perm, pname, aa);
  114. }
  115.  
  116. Visible value file_names;
  117.  
  118. Hidden Procedure
  119. def_perm(pname, f)
  120.     value pname, f;
  121. {
  122.     e_replace(f, &b_perm, pname);
  123.     if (!in(f, file_names)) insert(f, &file_names);
  124. }
  125.  
  126. Hidden Procedure
  127. free_perm(pname)
  128.     value pname;
  129. {
  130.     value *aa;
  131.     if (p_exists(pname, &aa)) {
  132.         remove(*aa, &file_names);
  133.         f_delete(*aa);
  134.         e_delete(&b_perm, pname);
  135.     }
  136. }
  137.  
  138. Hidden value
  139. get_fname(pname)
  140.     value pname;
  141. {
  142.     value *aa;
  143.     if (p_exists(pname, &aa)) return copy(*aa);
  144.     else {
  145.         value fname, name; literal type;
  146.         p_name_type(pname, &name, &type);
  147.         fname= new_fname(name, type);
  148.         def_perm(pname, fname);
  149.         release(name);
  150.         return fname;
  151.     }
  152. }
  153.  
  154. Hidden bool
  155. p_version(name, type, pname)
  156.     value name, *pname; literal type;
  157. {
  158.     value *aa;
  159.     *pname= permkey(name, type);
  160.     if (p_exists(*pname, &aa)) return Yes;
  161.     release(*pname); *pname= Vnil;
  162.     return No;
  163. }
  164.  
  165. Hidden bool
  166. how_unit(pname)
  167.     value pname;
  168. {
  169.     value name; literal type;
  170.     p_name_type(pname, &name, &type);
  171.     release(name);
  172.     return type == How;
  173. }
  174.  
  175. Hidden bool
  176. zermon_units(pname, other_pname)
  177.     value pname, *other_pname;
  178. {
  179.     value name; literal type; bool is;
  180.     p_name_type(pname, &name, &type);
  181.     is= (type == Zer && p_version(name, Mon, other_pname)) ||
  182.         (type == Mon && p_version(name, Zer, other_pname));
  183.     release(name);
  184.     return is;
  185. }
  186.  
  187. /***********************************************************************/
  188.  
  189. Hidden bool
  190. is_loaded(pname, aa)
  191.     value pname, **aa;
  192. {
  193.     value u= Vnil, npname= Vnil, get_unit();
  194.     if (u_exists(pname, aa)) return Yes; /* already loaded */
  195.     if (!p_exists(pname, aa)) return No;
  196.     ifile= fopen(strval(**aa), "r");
  197.     if (ifile == NULL) {
  198.         vs_ifile();
  199.         return No;
  200.     }
  201.     Eof= No;
  202.     first_ilev();
  203.     u= get_unit(&npname, Yes);
  204.     if (still_ok) def_unit(npname, u);
  205.     fclose(ifile);
  206.     vs_ifile();
  207.     Eof= No;
  208.     if (still_ok && !u_exists(pname, aa)) {
  209.         value name; literal type;
  210.         p_name_type(npname, &name, &type);
  211.         release(uname); uname= copy(pname);
  212.         curline= How_to(u)->unit; curlino= one;
  213.         error2(MESS(4002, "filename and unit name incompatible for "), name);
  214.         release(name);
  215.     }
  216.     release(u); release(npname);
  217.     return still_ok;
  218. }
  219.  
  220. /* Does the unit exist without faults? */
  221.  
  222. Visible bool
  223. is_unit(name, type, aa)
  224.     value name, **aa; literal type;
  225. {
  226.     value pname;
  227.     context c; bool is;
  228.     sv_context(&c);
  229.     cntxt= In_unit;
  230.     pname= permkey(name, type);
  231.     is= is_loaded(pname, aa);
  232.     release(pname);
  233.     set_context(&c);
  234.     return is;
  235. }
  236.  
  237. /***********************************************************************/
  238.  
  239. Hidden char DISCARD[]= "the unit name is already in use;\n\
  240. *** should the old unit be discarded?";
  241.  
  242. #define CANT_WRITE \
  243.     MESS(4003, "cannot create file; need write permission in directory")
  244.  
  245. #define CANT_READ MESS(4004, "unable to find file")
  246. #define MON_VERSION MESS(4005, " is already a monadic function/predicate")
  247. #define ZER_VERSION MESS(4006, " is already a zeroadic function/predicate")
  248.  
  249. Hidden Procedure
  250. u_name_type(v, name, type)
  251.     parsetree v; value *name; literal *type;
  252. {
  253.     switch (Nodetype(v)) {
  254.         case HOW_TO:    *name= copy(*Branch(v, UNIT_NAME));
  255.                 *type= How;
  256.                 break;
  257.         case YIELD:
  258.         case TEST:    *name= copy(*Branch(v, UNIT_NAME));
  259.                 switch (intval(*Branch(v, FPR_ADICITY))) {
  260.                     case 0: *type= Zer; break;
  261.                     case 1: *type= Mon; break;
  262.                     case 2: *type= Dya; break;
  263.                     default: syserr(MESS(4007, "wrong adicity"));
  264.                 }
  265.                 break;
  266.         default:    syserr(MESS(4008, "wrong nodetype of unit"));
  267.     }
  268. }
  269.  
  270. Hidden value
  271. get_unit(pname, filed)
  272.     value *pname; bool filed;
  273. {
  274.     value name; literal type;
  275.     parsetree u= unit(No);
  276.     if (u == NilTree) return Vnil;
  277.     u_name_type(u, &name, &type);
  278.     *pname= permkey(name, type);
  279.     release(name);
  280.     switch (Nodetype(u)) {
  281.         case HOW_TO:    return mk_how(u, filed);
  282.         case YIELD:    return mk_fun(type, Use, u, filed);
  283.         case TEST:    return mk_prd(type, Use, u, filed);
  284.         default:    syserr(MESS(4009, "wrong nodetype in 'get_unit'"));
  285.     }
  286.     /* NOTREACHED */
  287. }
  288.  
  289. Visible value
  290. get_pname(v)
  291.     parsetree v;
  292. {
  293.     value pname, name; literal type;
  294.     u_name_type(v, &name, &type);
  295.     pname= permkey(name, type);
  296.     release(name);
  297.     return pname;
  298. }
  299.  
  300. Hidden Procedure
  301. get_heading(h, pname)
  302.     parsetree *h; value *pname;
  303. {
  304.     *h= unit(Yes);
  305.     *pname= still_ok ? get_pname(*h) : Vnil;
  306. }
  307.  
  308. /* Create a unit via the editor or from the input stream */
  309.  
  310. Visible Procedure
  311. create_unit()
  312. {
  313.     value pname= Vnil, *aa; parsetree heading= NilTree;
  314.     if (!interactive) {
  315.         value v= get_unit(&pname, No);
  316.         if (still_ok) def_unit(pname, v);
  317.         release(v); release(pname);
  318.         return;
  319.     }
  320.     get_heading(&heading, &pname);
  321.     if (still_ok) {
  322.         value v;
  323.         if (p_exists(pname, &aa)) {
  324.             if (is_intended(DISCARD)) {
  325.                 free_unit(pname);
  326.                 free_perm(pname);
  327.             } else {
  328.                 tx= ceol;
  329.                 release(pname);
  330.                 release(heading);
  331.                 return;
  332.             }
  333.         } else if (zermon_units(pname, &v)) {
  334.             value name; literal type;
  335.             p_name_type(pname, &name, &type);
  336.             curline= heading; curlino= one;
  337.             error3(0, name, type == Zer ? MON_VERSION
  338.                              : ZER_VERSION);
  339.             release(name); release(v);
  340.         }
  341.     }
  342.     if (still_ok) {
  343.         value fname= get_fname(pname);
  344.         FILE *ofile= fopen(strval(fname), "w");
  345.         if (ofile == NULL) error(CANT_WRITE);
  346.         else {
  347.             txptr tp= fcol();
  348.             do { fputc(Char(tp), ofile); }
  349.             while (Char(tp++) != '\n');
  350.             f_close(ofile);
  351.             ed_unit(pname, fname);
  352.         }
  353.         release(fname);
  354.     }
  355.     release(pname); release(heading);
  356. }
  357.  
  358.  
  359. /***********************************************************************/
  360.  
  361. /* Edit a unit. The name of the unit is either given, or is defaulted
  362.    to the last unit edited or the last unit that gave an error, whichever
  363.    was most recent.
  364.    It is possible for the user to mess things up with the w command, for
  365.    instance, but this is not checked. It is allowed to rename the unit though,
  366.    or delete it completely. If the file is empty, the unit is disposed of.
  367.    Otherwise, the name and adicity are determined and if these have changed,
  368.    the new unit is written out to a new file, and the original written back.
  369.    Thus the original is not lost.
  370.  
  371.    Renaming, deleting, or changing the adicity of a test or yield
  372.    unfortunately requires all other units to be thrown away internally
  373.    (by del_units), since the unit parse trees may be wrong. For instance,
  374.    consider the effect on the following of making a formerly monadic
  375.    function f, into a zeroadic function:
  376.     WRITE f root 2
  377. */
  378.  
  379. Hidden char ZEROADIC[]=
  380.    "the unit name is in use both for a zeroadic and a dyadic version;\n\
  381. *** do you want to edit the zeroadic version?";
  382.  
  383. Hidden char MONADIC[]=
  384.    "the unit name is in use both for a monadic and a dyadic version;\n\
  385. *** do you want to edit the monadic version?";
  386.  
  387. Visible Procedure
  388. edit_unit()
  389. {
  390.     value name= Vnil, pname= Vnil, v= Vnil; bool ens_filed();
  391.     value fname;
  392.     if (Ceol(tx)) {
  393.         if (erruname == Vnil) parerr(MESS(4010, "no current unit"));
  394.         else pname= copy(erruname);
  395.     } else if (is_keyword(&name))
  396.         pname= permkey(name, How);
  397.      else if (is_tag(&name)) {
  398.         if (p_version(name, Zer, &pname)) {
  399.             if (p_version(name, Dya, &v) && !is_intended(ZEROADIC)) {
  400.                 release(pname); pname= copy(v);
  401.             }
  402.         } else if (p_version(name, Mon, &pname)) {
  403.             if (p_version(name, Dya, &v) && !is_intended(MONADIC)) {
  404.                 release(pname); pname= copy(v);
  405.             }
  406.         } else {
  407.             pname= permkey(name, Dya);
  408.         }
  409.     } else {
  410.         parerr(MESS(4011, "I find nothing editible here"));
  411.     }
  412.     if (still_ok && ens_filed(pname, &fname)) {
  413.         ed_unit(pname, fname);
  414.         release(fname);
  415.     }
  416.     release(name); release(pname); release(v);
  417. }
  418.  
  419. Hidden char NO_U_WRITE[]=
  420.    "you have no write permission in this workspace: you may not change the unit\n\
  421. *** do you still want to display the unit?";
  422.  
  423. Hidden char ZER_MON[]=
  424.    "the unit name is already in use for a zeroadic function or predicate;\n\
  425. *** should that unit be discarded?\n\
  426. *** (if not you have to change the monadic unit name)";
  427.  
  428. Hidden char MON_ZER[]=
  429.    "the unit name is already in use for a monadic function or predicate;\n\
  430. *** should that unit be discarded?\n\
  431. *** (if not you have to change the zeroadic unit name)";
  432.  
  433. Hidden Procedure
  434. ed_unit(pname, fname)
  435.     value pname, fname;
  436. {
  437.     value sname= Vnil, npname= Vnil, nfname= Vnil;
  438.     value u, *aa, v= Vnil, v_free= Vnil;
  439.     intlet err_line();
  440.     bool new_def= Yes, same_name= No, still_there(), ed_again= No;
  441.  
  442.     if (!ws_writable() && !is_intended(NO_U_WRITE)) return;
  443.     sname= f_save(fname); /* in case the unit gets renamed */
  444.     if (sname == Vnil) {
  445.         error(MESS(4012, "can't save to temporary file"));
  446.         return;
  447.     }
  448.     release(uname); uname= copy(pname);
  449. #ifndef INTEGRATION
  450.     f_edit(fname, err_line(pname));
  451. #else
  452.     f_edit(fname, err_line(pname), unit_prompt);
  453. #endif
  454.     if (!still_there(fname)) {
  455.         free_unit(pname);
  456.         if (!how_unit(pname)) del_units();
  457.         release(erruname); erruname= Vnil; errlino= 0;
  458.         free_perm(pname);
  459.         f_delete(sname);
  460.         release(sname);
  461.         return;
  462.     }
  463.     first_ilev();
  464.     u= get_unit(&npname, Yes);
  465.     fclose(ifile); vs_ifile(); Eof= No;
  466.     if (u == Vnil || npname == Vnil)
  467.         new_def= No;
  468.     else if (same_name= compare(pname, npname) == 0)
  469.         new_def= p_exists(pname, &aa);
  470.     else if (p_exists(npname, &aa))
  471.         new_def= is_intended(DISCARD);
  472.     else if (zermon_units(npname, &v)) {
  473.         value name; literal type;
  474.         p_name_type(npname, &name, &type);
  475.         if (new_def= is_intended(type == Zer ? MON_ZER : ZER_MON)) {
  476.             free_unit(v);
  477.             v_free= copy(v); /* YIELD f => YIELD f x */
  478.         } else {
  479.             nfname= new_fname(name, type);
  480.             f_rename(fname, nfname);
  481.             ed_again= Yes;
  482.         }
  483.         release(name);
  484.     }
  485.     if (new_def) {
  486.         if (!how_unit(npname)) del_units();
  487.         if (still_ok) def_unit(npname, u);
  488.         else free_unit(npname);
  489.         if (!same_name) {
  490.             nfname= get_fname(npname);
  491.             f_rename(fname, nfname);
  492.             if (v_free) free_perm(v_free);
  493.         }
  494.         release(erruname); erruname= copy(npname);
  495.     }
  496.     if (!same_name) f_rename(sname, fname);
  497.     else f_delete(sname);
  498.     if (!p_exists(pname, &aa)) f_delete(fname);
  499.     if (ed_again) ed_unit(npname, nfname);
  500.     release(npname); release(u); release(sname); release(nfname);
  501.     release(v); release(v_free);
  502. }
  503.  
  504. /* Find out if the file exists, and is not empty. Some wretched editors
  505.    for some reason don't allow a file to be edited to empty, but insist it
  506.    should be at least one empty line. Thus an initial empty line may be
  507.    disregarded, but this is not harmful. */
  508.  
  509. Hidden bool still_there(fname) value fname; {
  510.     int k;
  511.     ifile= fopen(strval(fname), "r");
  512.     if (ifile == NULL) {
  513.         vs_ifile();
  514.         /* error(CANT_READ); */
  515.         return No;
  516.     } else {
  517.         if ((k= getc(ifile)) == EOF || (k == '\n' && (k= getc(ifile)) == EOF)) {
  518.             fclose(ifile);
  519.             f_delete(fname);
  520.             vs_ifile();
  521.             return No;
  522.         }
  523.         ungetc(k, ifile);
  524.         return Yes;
  525.     }
  526. }
  527.  
  528. /* Ensure the unit is filed. If the unit was read non-interactively (eg passed
  529.    as a parameter to b), it is only held in store.
  530.    Editing it puts it into a file. This is the safest way to copy a unit from
  531.    one workspace to another.
  532. */
  533.  
  534. Hidden bool
  535. ens_filed(pname, fname)
  536.     value pname, *fname;
  537. {
  538.     value *aa;
  539.     if (p_exists(pname, &aa)) {
  540.         *fname= copy(*aa);
  541.         return Yes;
  542.     } else if (!u_exists(pname, &aa) || How_to(*aa)->unit == NilTree) {
  543.         pprerr(MESS(4013, "no such unit in this workspace"));
  544.         return No;
  545.     } else {
  546.         how *du= How_to(*aa); FILE *ofile;
  547.         if (du->filed == Yes) {
  548.             syserr(MESS(4014, "ens_filed()"));
  549.             return No;
  550.         }
  551.         *fname= get_fname(pname);
  552.         ofile= fopen(strval(*fname), "w");
  553.         if (!ofile) {
  554.             error(CANT_WRITE);
  555.             release(*fname);
  556.             return No;
  557.         } else {
  558.             display(ofile, du->unit, No);
  559.             f_close(ofile);
  560.             du->filed= Yes;
  561.             return Yes;
  562.         }
  563.     }
  564. }
  565.  
  566. Hidden intlet
  567. err_line(pname)
  568.     value pname;
  569. {
  570.     if (errlino == 0 || erruname == Vnil || compare(erruname, pname) != 0)
  571.         return 0;
  572.     else {
  573.         intlet el= errlino;
  574.         errlino= 0;
  575.         return el;
  576.     }
  577. }
  578.  
  579. /************************** VALUES ***************************************/
  580. /* The permanent environment in the old format was kept as a single file */
  581. /* but this caused slow start ups if the file was big.             */
  582. /* Thus the new version stores each permanent target on a separate file, */
  583. /* that furthermore is only loaded on demand.                 */
  584. /* To achieve this, a directory is kept of the permanent tags and their  */
  585. /* file names. Care has to be taken that disaster occurring in         */
  586. /* the middle of an update of this directory does the least harm.     */
  587. /* Having the directory refer to a non-existent file is considered less  */
  588. /* harmful than leaving a file around that can never be accessed, for     */
  589. /* instance, so a file is deleted before its directory entry,         */
  590. /* and so forth.                             */
  591. /*************************************************************************/
  592.  
  593. Hidden bool
  594. t_exists(name, aa)
  595.     value name, **aa;
  596. {
  597.     return in_env(prmnv->tab, name, aa);
  598. }
  599.  
  600. Hidden Procedure
  601. def_target(name, t)
  602.     value name, t;
  603. {
  604.     e_replace(t, &prmnv->tab, name);
  605. }
  606.  
  607. Hidden Procedure
  608. free_target(name)
  609.     value name;
  610. {
  611.     e_delete(&prmnv->tab, name);
  612. }
  613.  
  614. Hidden Procedure
  615. tarfiled(name, v)
  616.     value name, v;
  617. {
  618.     value p= mk_per(v);
  619.     def_target(name, p);
  620.     release(p);
  621. }
  622.  
  623. Visible value
  624. tarvalue(name, v)
  625.     value name, v;
  626. {
  627.     value getval();
  628.     if (Is_filed(v)) {
  629.         per *p= Perm(v);
  630.         if (p->val == Vnil) {
  631.             value *aa, pname= permkey(name, Tar);
  632.             if (!p_exists(pname, &aa))
  633.                 syserr(MESS(4015, "tarvalue"));
  634.             release(pname);
  635.             p->val= getval(*aa, In_tarval);
  636.         }
  637.         return p->val;
  638.     }
  639.     return v;
  640. }
  641.  
  642. Hidden value last_tname= Vnil; /*last edited target */
  643.  
  644. Visible Procedure
  645. edit_target()
  646.  {
  647.     value name= Vnil; bool ens_tfiled();
  648.     value fname;
  649.     if (Ceol(tx)) {
  650.         if (last_tname == Vnil)
  651.             parerr(MESS(4016, "no current target"));
  652.         else
  653.             name= copy(last_tname);
  654.     } else if (!is_tag(&name))
  655.         parerr(MESS(4017, "I find nothing editible here"));
  656.     if (still_ok && ens_tfiled(name, &fname)) {
  657.         ed_target(name, fname);
  658.         release(fname);
  659.     }
  660.     release(name);
  661. }
  662.  
  663. Hidden char NO_T_WRITE[]=
  664.    "you have no write permission in this workspace: you may not change the target\n\
  665. *** do you still want to display the target?";
  666.  
  667. Hidden Procedure
  668. ed_target(name, fname)
  669.     value name, fname;
  670. {
  671.     /* Edit a target. The value in the target is written to the file,
  672.        and then removed from the internal permanent environment so that
  673.        if a syntax error occurs when reading the value back, the value is
  674.        absent from the internal permanent environment.
  675.        Thus when editing the file to correct the syntax error, the
  676.        file doesn't get overwritten.
  677.        The contents may be completely deleted in which case the target is
  678.        deleted.
  679.     */
  680.     value v, getval();
  681.     if (!ws_writable() && !is_intended(NO_T_WRITE)) return;
  682. #ifndef INTEGRATION
  683.     f_edit(fname, 0);
  684. #else
  685.     f_edit(fname, 0, tar_prompt);
  686. #endif
  687.     if (!still_there(fname)) {
  688.         value pname= permkey(name, Tar);
  689.         free_target(name);
  690.         free_perm(pname);
  691.         release(pname);
  692.         release(last_tname); last_tname= Vnil;
  693.         return;
  694.     }
  695.     release(last_tname); last_tname= copy(name);
  696.     fclose(ifile); /*since still_there leaves it open*/
  697.     v= getval(fname, In_edval);
  698.     if (still_ok) def_target(name, v);
  699.     release(v);
  700. }
  701.  
  702. Hidden bool
  703. ens_tfiled(name, fname)
  704.     value name, *fname;
  705. {
  706.     value *aa;
  707.     if (!t_exists(name, &aa)) {
  708.         pprerr(MESS(4018, "no such target in this workspace"));
  709.         return No;
  710.     } else {
  711.         value pname= permkey(name, Tar);
  712.         *fname= get_fname(pname);
  713.         if (!Is_filed(*aa)) {
  714.             putval(*fname, *aa, No);
  715.             tarfiled(name, *aa);
  716.         }
  717.         release(pname);
  718.         return Yes;
  719.     }
  720. }
  721.  
  722. /***************************** Values on files ****************************/
  723.  
  724. Hidden value
  725. getval(fname, ct)
  726.     value fname;
  727.     literal ct; /* context */
  728. {
  729.     char *buf= Nil; int k; parsetree e, code; value v= Vnil;
  730.     ifile= fopen(strval(fname), "r");
  731.     if (ifile) {
  732.         txptr fcol_save= first_col, tx_save= tx; context c;
  733.         sv_context(&c);
  734.         cntxt= ct;
  735.         buf= getmem((unsigned)(f_size(ifile)+2)*sizeof(char));
  736.         if (buf == Nil)
  737.             syserr(MESS(4019, "can't get buffer to read file"));
  738.         first_col= tx= ceol= buf;
  739.         while ((k= getc(ifile)) != EOF)
  740.             if (k != '\n') *ceol++= k;
  741.         *ceol= '\n';
  742.         fclose(ifile); vs_ifile();
  743.         e= expr(ceol);
  744.         if (still_ok) fix_nodes(&e, &code);
  745.         curline=e; curlino= one;
  746.         v= evalthread(code); curline= Vnil;
  747.         release(e);
  748.         if (buf != Nil) freemem((ptr) buf);
  749.         set_context(&c);
  750.         first_col= fcol_save; tx= tx_save;
  751.     } else {
  752.         error(CANT_READ);
  753.         vs_ifile();
  754.     }
  755.     return v;
  756. }
  757.  
  758. Visible Procedure
  759. getprmnv()
  760. {
  761.     intlet k, len; value name, fname; literal type;
  762.     if (f_exists(BPERMFILE)) {
  763.         value fn;
  764.         fn= mk_text(BPERMFILE);
  765.         b_perm= getval(fn, In_prmnv);
  766.         release(fn);
  767.         if (!still_ok) exit(1);
  768.         len= length(b_perm);
  769.         k_Over_len {
  770.             p_name_type(*key(b_perm, k), &name, &type);
  771.             if (type == Tar) tarfiled(name, Vnil);
  772.             fname= copy(*assoc(b_perm, k));
  773.             insert(fname, &file_names);
  774.             release(fname); release(name);
  775.         }
  776.     } else
  777.         b_perm= mk_elt();
  778.  
  779. #ifdef CONVERSION
  780.     if (f_exists(PRMNVFILE)) { /* convert from old to new format */
  781.         value tab, v, pname, new_fname();
  782.         value fn= mk_text(PRMNVFILE), save= mk_text(SAVEPRMNVFILE);
  783.         tab= getval(fn, In_prmnv);
  784.         if (!still_ok) exit(1);
  785.         len= length(tab);
  786.         k_Over_len {
  787.             name= copy(*key(tab, k));
  788.             v= copy(*assoc(tab, k));
  789.             def_target(name, v);
  790.             pname= permkey(name, Tar);
  791.             fname= get_fname(pname);
  792.             putval(fname, v, Yes);
  793.             tarfiled(name, v);
  794.             release(name); release(v); release(fname);
  795.             release(pname);
  796.         }
  797.         f_rename(fn, save);
  798.         if (len > 0)
  799.             printf("*** [Old permanent environment converted]\n");
  800.         release(tab); release(fn); release(save);
  801.     }
  802. #endif CONVERSION
  803. }
  804.  
  805. Hidden Procedure
  806. putval(fname, v, silently)
  807.     value fname, v; bool silently;
  808. {
  809.     FILE *ofile; value fn= mk_text(tempfile); bool was_ok= still_ok;
  810.     ofile= fopen(strval(fn), "w");
  811.     if (ofile != NULL) {
  812.         redirect(ofile);
  813.         still_ok= Yes;
  814.         wri(v, No, No, Yes); newline();
  815.         f_close(ofile);
  816.         redirect(stdout);
  817.         if (still_ok) f_rename(fn, fname);
  818.     } else if (!silently) error(CANT_WRITE);
  819.     still_ok= was_ok;
  820.     release(fn);
  821. }
  822.  
  823. Visible Procedure
  824. putprmnv()
  825. {
  826.     static bool active;
  827.     value v, name, fname, fn, *aa, pname; literal type;
  828.     int k, len;
  829.     if (active) return;
  830.     active= Yes;
  831.     len= length(b_perm);
  832.     for (k= len-1; k>=0; --k) {
  833.         p_name_type(*key(b_perm, k), &name, &type);
  834.         if (type == Tar && !t_exists(name, &aa))
  835.             free_perm(*key(b_perm, k));
  836.         release(name);
  837.     }
  838.     len= length(prmnv->tab);
  839.     k_Over_len {
  840.         v= copy(*assoc(prmnv->tab, k));
  841.         if (!Is_filed(v)) {
  842.             name= copy(*key(prmnv->tab, k));
  843.             pname= permkey(name, Tar);
  844.             fname= get_fname(pname);
  845.             putval(fname, v, Yes);
  846.             tarfiled(name, v);
  847.             release(name); release(fname); release(pname);
  848.         }
  849.         release(v);
  850.     }
  851.     fn= mk_text(BPERMFILE);
  852.     putval(fn, b_perm, Yes);
  853.     /* Remove the file if the permanent environment is empty */
  854.     if (length(b_perm) == 0) f_delete(fn);
  855.     release(fn);
  856.     active= No;
  857. }
  858.  
  859. Visible Procedure
  860. initsou()
  861. {
  862.     b_units= mk_elt();
  863.     file_names= mk_elt();
  864. }
  865.  
  866. Visible Procedure
  867. endsou()
  868. {
  869.     /* Release everything around so "memory leakage" can be detected */
  870.     release(b_units); b_units= Vnil;
  871.     release(b_perm); b_perm= Vnil;
  872.     release(file_names); file_names= Vnil;
  873.     release(last_tname); last_tname= Vnil;
  874. }
  875.  
  876. Visible Procedure
  877. lst_uhds()
  878. {
  879.     intlet k, len= length(b_perm); int c;
  880.     value name; literal type;
  881.     k_Over_len {
  882.         p_name_type(*key(b_perm, k), &name, &type);
  883.         if (type != Tar) {
  884.             FILE *fn= fopen(strval(*assoc(b_perm, k)), "r");
  885.             if (fn) {
  886.                 while ((c= getc(fn)) != EOF && c != '\n')
  887.                     putc(c, stdout);
  888.                 putc('\n', stdout);
  889.                 fclose(fn);
  890.             }
  891.         }
  892.         release(name);
  893.     }
  894.     len= length(b_units);
  895.     k_Over_len {
  896.         how *u= How_to(*assoc(b_units, k));
  897. #ifndef TRY
  898.         value *aa;
  899.         if (u -> filed == No && !p_exists(*key(b_units, k), &aa))
  900. #else
  901.         if (u -> filed == No)
  902. #endif
  903.             display(stdout, u -> unit, Yes);
  904.     }
  905.     fflush(stdout);
  906. }
  907.